home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / dfun.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  34KB  |  904 lines
  1. ;;; -*- Mode:LISP; Package:PCL; Base:10; Syntax:Common-Lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. #|
  31.  
  32. This implementation of method lookup was redone in early August of 89.
  33.  
  34. It has the following properties:
  35.  
  36.  - It's modularity makes it easy to modify the actual caching algorithm.
  37.    The caching algorithm is almost completely separated into the files
  38.    cache.lisp and dlap.lisp.  This file just contains the various uses
  39.    of it. There will be more tuning as we get more results from Luis'
  40.    measurements of caching behavior.
  41.  
  42.  - The metacircularity issues have been dealt with properly.  All of
  43.    PCL now grounds out properly.  Moreover, it is now possible to have
  44.    metaobject classes which are themselves not instances of standard
  45.    metaobject classes.
  46.  
  47. ** Modularity of the code **
  48.  
  49. The actual caching algorithm is isolated in a modest number of functions.
  50. The code which generates cache lookup code is all found in cache.lisp and
  51. dlap.lisp.  Certain non-wrapper-caching special cases are in this file.
  52.  
  53.  
  54. ** Handling the metacircularity **
  55.  
  56. In CLOS, method lookup is the potential source of infinite metacircular
  57. regress.  The metaobject protocol specification gives us wide flexibility
  58. in how to address this problem.  PCL uses a technique which handles the
  59. problem not only for the metacircular language described in Chapter 3, but
  60. also for the PCL protocol which includes additional generic functions
  61. which control more aspects of the CLOS implementation.
  62.  
  63. The source of the metacircular regress can be seen in a number of ways.
  64. One is that the specified method lookup protocol must, as part of doing
  65. the method lookup (or at least the cache miss case), itself call generic
  66. functions.  It is easy to see that if the method lookup for a generic
  67. function ends up calling that same generic function there can be trouble.
  68.  
  69. Fortunately, there is an easy solution at hand.  The solution is based on 
  70. the restriction that portable code cannot change the class of a specified
  71. metaobject.  This restriction implies that for specified generic functions,
  72. the method lookup protocol they follow is fixed.  
  73.  
  74. More precisely, for such specified generic functions, most generic functions
  75. that are called during their own method lookup will not run portable methods. 
  76. This allows the implementation to usurp the actual generic function call in
  77. this case.  In short, method lookup of a standard generic function, in the
  78. case where the only applicable methods are themselves standard doesn't
  79. have to do any method lookup to implement itself.
  80.  
  81. And so, we are saved.
  82.  
  83. |#
  84.  
  85.  
  86.  
  87. ;An alist in which each entry is of the form :
  88. ;  (<generator> . (<subentry> ...))
  89. ;Each subentry is of the form:
  90. ;  (<args> <constructor> <system>)
  91. (defvar *dfun-constructors* ())            
  92.  
  93. ;If this is NIL, then the whole mechanism
  94. ;for caching dfun constructors is turned
  95. ;off.  The only time that makes sense is
  96. ;when debugging LAP code. 
  97. (defvar *enable-dfun-constructor-caching* t)    
  98.  
  99. (defun show-dfun-constructors ()
  100.   (format t "~&DFUN constructor caching is ~A." 
  101.       (if *enable-dfun-constructor-caching*
  102.           "enabled" "disabled"))
  103.   (dolist (generator-entry *dfun-constructors*)
  104.     (dolist (args-entry (cdr generator-entry))
  105.       (format t "~&~S ~S"
  106.           (cons (car generator-entry) (caar args-entry))
  107.           (caddr args-entry)))))
  108.  
  109.  
  110. (declaim (ftype (function (T &rest T) real-function) get-dfun-constructor))
  111. (defun get-dfun-constructor (generator &rest args)
  112.   (let* ((generator-entry (assq generator *dfun-constructors*))
  113.      (args-entry (assoc args (cdr generator-entry) :test #'equal)))
  114.     (if (null *enable-dfun-constructor-caching*)
  115.     (apply-function (symbol-function generator) args)
  116.     (or (cadr args-entry)
  117.         (let ((new (apply-function (symbol-function generator) args)))
  118.           (if generator-entry
  119.           (push (list (copy-list args) new nil) (cdr generator-entry))
  120.           (push (list generator (list (copy-list args) new nil)) *dfun-constructors*))
  121.           new)))))
  122.  
  123. (defun load-precompiled-dfun-constructor (generator args system constructor)
  124.   (let* ((generator-entry (assq generator *dfun-constructors*))
  125.      (args-entry (assoc args (cdr generator-entry) :test #'equal)))
  126.     (unless args-entry
  127.       (if generator-entry
  128.       (push (list args constructor system) (cdr generator-entry))
  129.       (push (list generator (list args constructor system)) *dfun-constructors*)))))
  130.  
  131. (defmacro precompile-dfun-constructors (&optional system)
  132.   #+excl (declare (ignore system))
  133.   #+excl ()
  134.   #-excl
  135.   (let ((*precompiling-lap* t))
  136.     `(progn
  137.        ,@(gathering1 (collecting)
  138.        (dolist (generator-entry *dfun-constructors*)
  139.          (dolist (args-entry (cdr generator-entry))
  140.            (when (or (null (caddr args-entry))
  141.              (eq (caddr args-entry) system))
  142.          (when system (setf (caddr args-entry) system))
  143.          (multiple-value-bind (closure-variables arguments 
  144.                              iregs vregs fvregs tregs lap)
  145.              (apply-function (symbol-function (car generator-entry))
  146.                                      (car args-entry))
  147.            (gather1
  148.              (make-top-level-form `(precompile-dfun-constructor 
  149.                         ,(car generator-entry))
  150.                       '(load)
  151.                `(load-precompiled-dfun-constructor
  152.               ',(car generator-entry)
  153.               ',(car args-entry)
  154.               ',system
  155.               (precompile-lap-closure-generator ,closure-variables
  156.                                 ,arguments
  157.                                 ,iregs
  158.                                 ,vregs
  159.                                                 ,fvregs
  160.                                 ,tregs
  161.                                 ,lap))))))))))))
  162.  
  163.  
  164. ;;;
  165. ;;; When all the methods of a generic function are automatically generated
  166. ;;; reader or writer methods a number of special optimizations are possible.
  167. ;;; These are important because of the large number of generic functions of
  168. ;;; this type.
  169. ;;;
  170. ;;; There are a number of cases:
  171. ;;;
  172. ;;;   ONE-CLASS-ACCESSOR
  173. ;;;     In this case, the accessor generic function has only been called
  174. ;;;     with one class of argument.  There is no cache vector, the wrapper
  175. ;;;     of the one class, and the slot index are stored directly as closure
  176. ;;;     variables of the discriminating function.  This case can convert to
  177. ;;;     either of the next kind.
  178. ;;;
  179. ;;;   TWO-CLASS-ACCESSOR
  180. ;;;     Like above, but two classes.  This is common enough to do specially.
  181. ;;;     There is no cache vector.  The two classes are stored a separate
  182. ;;;     closure variables.
  183. ;;;
  184. ;;;   ONE-INDEX-ACCESSOR
  185. ;;;     In this case, the accessor generic function has seen more than one
  186. ;;;     class of argument, but the index of the slot is the same for all
  187. ;;;     the classes that have been seen.  A cache vector is used to store
  188. ;;;     the wrappers that have been seen, the slot index is stored directly
  189. ;;;     as a closure variable of the discriminating function.  This case
  190. ;;;     can convert to the next kind.
  191. ;;;
  192. ;;;   N-N-ACCESSOR
  193. ;;;     This is the most general case.  In this case, the accessor generic
  194. ;;;     function has seen more than one class of argument and more than one
  195. ;;;     slot index.  A cache vector stores the wrappers